home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / construct.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  43KB  |  1,112 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28. ;;; This file defines the defconstructor and other make-instance optimization
  29. ;;; mechanisms.
  30. ;;; 
  31.  
  32. (in-package 'pcl)
  33.  
  34. ;;;
  35. ;;; defconstructor is used to define special purpose functions which just
  36. ;;; call make-instance with a symbol as the first argument.  The semantics
  37. ;;; of defconstructor is that it is equivalent to defining a function which
  38. ;;; just calls make-instance. The purpose of defconstructor is to provide
  39. ;;; PCL with a way of noticing these calls to make-instance so that it can
  40. ;;; optimize them.  Specific ports of PCL could just have their compiler
  41. ;;; spot these calls to make-instance and then call this code.  Having the
  42. ;;; special defconstructor facility is the best we can do portably.
  43. ;;; 
  44. ;;;
  45. ;;; A call to defconstructor like:
  46. ;;;
  47. ;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
  48. ;;;
  49. ;;; Is equivalent to a defun like:
  50. ;;;
  51. ;;;  (defun make-foo (a b &rest r)
  52. ;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
  53. ;;;
  54. ;;; Calls like the following are also legal:
  55. ;;;
  56. ;;;  (defconstructor make-foo foo ())
  57. ;;;  (defconstructor make-bar bar () :x *x* :y *y*)
  58. ;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
  59. ;;;
  60. ;;;
  61. ;;; The general idea of this implementation is that the expansion of the
  62. ;;; defconstructor form includes the creation of closure generators which
  63. ;;; can be called to create constructor code for the class.  The ways that
  64. ;;; a constructor can be optimized depends not only on the defconstructor
  65. ;;; form, but also on the state of the class and the generic functions in
  66. ;;; the initialization protocol.  Because of this, the determination of the
  67. ;;; form of constructor code to be used is a two part process.
  68. ;;;
  69. ;;; At compile time, make-constructor-code-generators looks at the actual
  70. ;;; defconstructor form and makes a list of appropriate constructor code
  71. ;;; generators.  All that is really taken into account here is whether
  72. ;;; any initargs are supplied in the call to make-instance, and whether
  73. ;;; any of those are constant.
  74. ;;;
  75. ;;; At constructor code generation time (see note about lazy evaluation)
  76. ;;; compute-constructor-code calls each of the constructor code generators
  77. ;;; to try to get code for this constructor.  Each generator looks at the
  78. ;;; state of the class and initialization protocol generic functions and
  79. ;;; decides whether its type of code is appropriate.  This depends on things
  80. ;;; like whether there are any applicable methods on initialize-instance,
  81. ;;; whether class slots are affected by initialization etc.
  82. ;;; 
  83. ;;;
  84. ;;; Constructor objects are funcallable instances, the protocol followed to
  85. ;;; to compute the constructor code for them is quite similar to the protocol
  86. ;;; followed to compute the discriminator code for a generic function.  When
  87. ;;; the constructor is first loaded, we install as its code a function which
  88. ;;; will compute the actual constructor code the first time it is called.
  89. ;;; 
  90. ;;; If there is an update to the class structure which might invalidate the
  91. ;;; optimized constructor, the special lazy constructor installer is put back
  92. ;;; so that it can compute the appropriate constructor when it is called.
  93. ;;; This is the same kind of lazy evaluation update strategy used elswhere
  94. ;;; in PCL.
  95. ;;;
  96. ;;; To allow for flexibility in the PCL implementation and to allow PCL users
  97. ;;; to specialize this constructor facility for their own metaclasses, there
  98. ;;; is an internal protocol followed by the code which loads and installs
  99. ;;; the constructors.  This is documented in the comments in the code.
  100. ;;;
  101. ;;; This code is also designed so that one of its levels, can be used to
  102. ;;; implement optimization of calls to make-instance which can't go through
  103. ;;; the defconstructor facility.  This has not been implemented yet, but the
  104. ;;; hooks are there.
  105. ;;;
  106. ;;;
  107.  
  108. (defmacro defconstructor
  109.       (name class lambda-list &rest initialization-arguments)
  110.   (expand-defconstructor class
  111.              name
  112.              lambda-list
  113.              (copy-list initialization-arguments)))
  114.  
  115. (defun expand-defconstructor (class-name name lambda-list supplied-initargs)
  116.   (let ((class (find-class class-name nil))
  117.     (supplied-initarg-names
  118.       (gathering1 (collecting)
  119.         (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
  120.           (gather1 name)))))
  121.     (when (null class)
  122.       (error "defconstructor form being compiled (or evaluated) before~@
  123.               class ~S is defined."
  124.          class-name))
  125.     `(progn
  126.        ;; In order to avoid undefined function warnings, we want to tell
  127.        ;; the compile time environment that a function with this name and
  128.        ;; this argument list has been defined.  The portable way to do this
  129.        ;; is with defun.
  130.        (proclaim '(notinline ,name))
  131.        (defun ,name ,lambda-list
  132.      (declare (ignore ,@(extract-parameters lambda-list)))
  133.      (error "Constructor ~S not loaded." ',name))
  134.  
  135.        ,(make-top-level-form `(defconstructor ,name)
  136.                  '(load eval)
  137.       `(load-constructor
  138.          ',class-name
  139.          ',(class-name (class-of class))
  140.          ',name
  141.          ',supplied-initarg-names
  142.          ;; make-constructor-code-generators is called to return a list
  143.          ;; of constructor code generators.  The actual interpretation
  144.          ;; of this list is left to compute-constructor-code, but the
  145.          ;; general idea is that it should be an plist where the keys
  146.          ;; name a kind of constructor code and the values are generator
  147.          ;; functions which return the actual constructor code.  The
  148.          ;; constructor code is usually a closures over the arguments
  149.          ;; to the generator.
  150.          ,(make-constructor-code-generators class
  151.                         name
  152.                         lambda-list
  153.                         supplied-initarg-names
  154.                         supplied-initargs))))))
  155.  
  156. (defun load-constructor (class-name metaclass-name constructor-name
  157.              supplied-initarg-names code-generators)
  158.   (let ((class (find-class class-name nil)))
  159.     (cond ((null class)
  160.        (error "defconstructor form being loaded (or evaluated) before~@
  161.                    class ~S is defined."
  162.           class-name))
  163.       ((neq (class-name (class-of class)) metaclass-name)
  164.        (error "When defconstructor ~S was compiled, the metaclass of the~@
  165.                    class ~S was ~S.  The metaclass is now ~S.~@
  166.                    The constructor must be recompiled."
  167.           constructor-name
  168.           class-name
  169.           metaclass-name
  170.           (class-name (class-of class))))
  171.       (t
  172.        (load-constructor-internal class
  173.                       constructor-name
  174.                       supplied-initarg-names
  175.                       code-generators)
  176.        constructor-name))))
  177.  
  178. ;;;
  179. ;;; The actual constructor objects.
  180. ;;; 
  181. (defclass constructor ()               
  182.      ((class                    ;The class with which this
  183.     :initarg :class                ;constructor is associated.
  184.     :reader constructor-class)        ;The actual class object,
  185.                         ;not the class name.
  186.                         ;      
  187.       (name                    ;The name of this constructor.
  188.     :initform nil                ;This is the symbol in whose
  189.     :initarg :name                ;func